;;;; colloquia.lisp

(in-package #:colloquia)

#|

READER

A little bit smarter than a lexer: whitespace-separated words are converted
into tokens, possibly grouped by means of || and //.  Punctuation is read in as
chars.

Strings are used rather than symbols, because they can be garbage-collected.

|#

(defun whitespacep (char)
  (member char '(#\Space #\Newline)))

(defvar *coll-macro-chars*)

(defun coll-read (&optional (stream *standard-input*))
  (let (c)
    (loop
      (setf c (read-char stream nil))
      (when (or (null c) (not (whitespacep c)))
        (return)))
    (if (null c)
        nil
        (let ((fun (cdr (assoc c *coll-macro-chars*))))
          (if fun
              (funcall fun stream c)
              (with-output-to-string (s)
                (write-char c s)
                (loop
                  (setf c (read-char stream nil))
                  (when (or (null c) (whitespacep c))
                    (return))
                  (when (assoc c *coll-macro-chars*)
                    (unread-char c stream)
                    (return))
                  (write-char c s))))))))

(defun coll-read-delimited (endchar stream)
  (let ((tokens '())
        (stop? nil))
    (flet ((stop (stream char)
             (declare (ignore stream char))
             (setf stop? t)))
      (let ((*coll-macro-chars* (acons endchar #'stop *coll-macro-chars*)))
        (loop
          (let ((token (coll-read stream)))
            (when stop?
              (return (nreverse tokens)))
            (when (null token)
              (error "Delimiter ~C not found" endchar))
            (push token tokens)))))))

(defun coll-read-delimited-lines (endline stream)
  (read-line stream)
  (do ((lines)
       (line (read-line stream) (read-line stream)))
      ((string= (string-right-trim " " line) endline) (nreverse lines))
      (push line lines)))

(defparameter *punctuation* ".,:;!?()«»")

(defun echo-reader (stream char)
  (declare (ignore stream))
  char)

(setf *coll-macro-chars* (append `((#\/ . ,(lambda (stream char)
                                             (declare (ignore char))
                                             (cons 'slash-group (coll-read-delimited #\/ stream))))
                                   (#\| . ,(lambda (stream char)
                                             (declare (ignore char))
                                             (cons 'bar-group (coll-read-delimited #\| stream))))
                                   (#\* . ,(lambda (stream char)
                                             (declare (ignore stream char))
                                             'star))
                                   (#\] . ,(lambda (stream char)
                                             (declare (ignore stream char))
                                             'bracket))
                                   (#\` . ,(lambda (stream char)
                                             (declare (ignore char))
                                             (let ((next-char (peek-char nil stream)))
                                               (if (alpha-char-p next-char)
                                                   'backquote
                                                   (cons 'backquote-group
                                                         (loop for line in (coll-read-delimited-lines "`" stream)
                                                               collect (with-input-from-string (s line)
                                                                         (loop for token = (coll-read s)
                                                                               while token
                                                                               collect token))))))))
                                   (#\~ . ,(lambda (stream char)
                                             (declare (ignore stream char))
                                             :unbreakable-space)))
                                 (loop for c across *punctuation*
                                       collect (cons c #'echo-reader))))

#|
The header uses a different, line-oriented reader.

The implementation is sloppy.
|#

(defun coll-read-header (stream)
  (loop with two-lines = (loop repeat 2
                               collect (read-line stream))
        for line in two-lines
        for tag in '(titulus personae)
        for tokens = (with-input-from-string (s (subseq line 8))
                       (loop for token = (coll-read s)
                             while token
                             collect token))
        collect (cons tag tokens)))

#|

PARSE

Formatting info is attached to single tokens (`words') as their `style'.  By
default, the style is NIL.  The only other style implemented is italic I.

The body text is made up of cues, notes, and possibly (rich) text outside of
those.  A cue (resp., a note) comprises the indication of person (resp., a star)
between bars and all subsequent text until the indication of another person or
a note.

Paragraphs have not been implemented yet.

|#

(defstruct (rich-word (:constructor %make-rich-word)
                      (:constructor make-rich-word (string &optional (style 'rm))))
  string
  style)

(defstruct (rich-char (:constructor %make-rich-char)
                      (:constructor make-rich-char (char &optional (style 'rm))))
  char
  style)

(defgeneric rich-style (element))

(defmethod rich-style (element)
  nil)

(defmethod rich-style ((element rich-word))
  (rich-word-style element))

(defmethod rich-style ((element rich-char))
  (rich-char-style element))

(defmethod rich-style ((element (eql 'bracket)))
  'rm)

(defstruct (rich-text (:constructor %make-rich-text)
                      (:constructor make-rich-text (words)))
  words)

(defparameter *leading-punctuation* "(«")
(defparameter *trailing-punctuation* ".,:;!?)»" )

(defgeneric space-between-p (item next-item))

(defmethod space-between-p (item next-item)
  t)

(defmethod space-between-p (item (next-item rich-char))
  (not (find (rich-char-char next-item) *trailing-punctuation*)))

(defmethod space-between-p ((item rich-char) next-item)
  (not (find (rich-char-char item) *leading-punctuation*)))

(defmethod space-between-p ((item rich-char) (next-item rich-char))
  (and (find (rich-char-char item) *trailing-punctuation*)
       (find (rich-char-char next-item) *leading-punctuation*)))

(defmethod space-between-p ((item rich-char) (next-item (eql :unbreakable-space)))
  nil)

(defmethod space-between-p ((item (eql :unbreakable-space)) (next-item rich-char))
  nil)

(defmethod space-between-p ((item (eql 'note-sign)) next-item)
  nil)

(defmethod space-between-p ((item (eql :unbreakable-space)) next-item)
  nil)

(defmethod space-between-p (item (next-item (eql :unbreakable-space)))
  nil)

(defstruct (cue (:constructor %make-cue)
                (:constructor make-cue (who what)))
  who
  what)

(defstruct (note (:constructor %make-note)
                 (:constructor make-note (text)))
  text)

(defstruct (title (:constructor %make-title)
                  (:constructor make-title (text)))
  text)

(defstruct (personae (:constructor %make-personae)
                     (:constructor make-personae (names)))
  names)

(defstruct (verse (:constructor %make-verse)
                  (:constructor make-verse (lines)))
  lines)

(defstruct dialogue
  title
  personae
  text
  notes)

(defgeneric coll-parse (tag tokens))

(defvar *rich-style* 'rm)

(defun parse-rich-words (tokens)
  (let ((words '())
        token
        (rest-tokens tokens))
    (loop
      (unless rest-tokens
        (return))
      (setf token (pop rest-tokens))
      (cond ((stringp token) (push (make-rich-word token *rich-style*) words))
            ((characterp token) (push (make-rich-char token *rich-style*) words))
            ((and (listp token)
                  (eql (first token) 'slash-group))
             (let ((*rich-style* 'it))
               (setf words (nconc (parse-rich-words (rest token)) words))))
            ((and (listp token)
                  (eql (first token) 'backquote-group))
             (push (coll-parse 'verse (list token)) words))
            ((eq token 'star) (push 'note-sign words))
            ((eq token 'bracket) (push 'bracket words))
            ((eq token :unbreakable-space) (push :unbreakable-space words))
            ((eq token 'backquote) (let ((roman (pop rest-tokens)))
                                     (push (make-rich-word (string-downcase roman) 'roman-numeral) words)))
            (t (push token rest-tokens) (return))))
    (values words rest-tokens)))

(defmethod coll-parse ((tag (eql 'rich-text)) tokens)
  (multiple-value-bind (words rest-tokens) (parse-rich-words tokens)
    (if words
        (values (make-rich-text (nreverse words)) rest-tokens)
        (values nil tokens))))

(defmethod coll-parse ((tag (eql 'cue)) tokens)
  (if (and (listp (first tokens))
           (eq (caar tokens) 'bar-group)
           (stringp (cadar tokens)))
      (multiple-value-bind (what rest-tokens) (coll-parse 'rich-text (rest tokens))
        (values (make-cue (cadar tokens) what) rest-tokens))
      (values nil tokens)))

(defmethod coll-parse ((tag (eql 'note)) tokens)
  (if (equal (first tokens) '(bar-group star))
      (multiple-value-bind (text rest-tokens) (coll-parse 'rich-text (rest tokens))
        (values (make-note text) rest-tokens))
      (values nil tokens)))

(defun group-parser (markup-tag constructor)
  (lambda (tokens)
    (if (and (listp (car tokens))
             (eq (caar tokens) markup-tag))
        (values (funcall constructor (cdar tokens))
                (cdr tokens))
        (values nil tokens))))

(defmethod coll-parse ((tag (eql 'verse)) tokens)
  (flet ((construct (lines)
           (make-verse (loop for line in lines
                             collect (coll-parse 'rich-text line )))))
    (funcall (group-parser 'backquote-group #'construct) tokens)))

(defun header-line-parser (markup-tag constructor)
  (lambda (tokens)
    (flet ((construct (words)
             (funcall constructor (coll-parse 'rich-text words))))
      (funcall (group-parser markup-tag #'construct) tokens))))

(defmethod coll-parse ((tag (eql 'titulus)) tokens)
  (funcall (header-line-parser 'titulus #'make-title) tokens))

(defmethod coll-parse ((tag (eql 'personae)) tokens)
  (funcall (header-line-parser 'personae #'make-personae) tokens))

;;; This one is sloppy
(defmethod coll-parse ((tag (eql 'dialogue)) tokens)
  (let ((parsed (list :title '()
                      :personae '()
                      :text '()
                      :notes '()))
        current-parsed
        (rest-tokens tokens)
        end?)
    (loop
      (setf end? t)
      (loop for (tag section) in '((cue :text)
                                   (note :notes)
                                   (rich-text :text)
                                   (verse :text)
                                   (titulus :title)
                                   (personae :personae))
            do (multiple-value-setq (current-parsed rest-tokens) (coll-parse tag rest-tokens))
            (when current-parsed 
              (setf end? nil)
              (push current-parsed (getf parsed section))))
      (when end?
        (return)))
    ;; :title and :personae are not lists
    (dolist (section '(:title :personae))
      (setf (getf parsed section) (first (getf parsed section))))
    (dolist (section '(:text :notes))
      (setf (getf parsed section) (nreverse (getf parsed section))))
    (values (apply #'make-dialogue parsed)
            nil)))

;; Façade
(defun parse-dialogue (tokens)
  (coll-parse 'dialogue tokens))

(defun read-dialogue (source)
  (flet ((do-read (in)
           (parse-dialogue (append (coll-read-header in)
                                   (loop for token = (coll-read in)
                                         while token
                                         collect token)))))
    (etypecase source
      (pathname (with-open-file (in source :direction :input)
                  (do-read in)))
      (string (with-open-file (in source :direction :input)
                (do-read in)))
      (stream (do-read source)))))

#|

LaTeX backend

|#


(defvar *tex-stream* *standard-output*)

(defgeneric to-tex (text &optional *tex-stream*))

(defmethod to-tex ((punctuation character) &optional (*tex-stream* *tex-stream*))
  (write-char punctuation *tex-stream*))

;;; TeXifying strings: escape ampersands, wrap Greek words in \textgreek
(defmethod to-tex ((string string) &optional (*tex-stream* *tex-stream*))
  (setf string (substitute #\Space #\Newline string))
  ;; Sloppy: I assume that the string is a single word
  (if (find-if (lambda (c)
                 (> (char-code c) 900))
               string)
      (format *tex-stream* "\\textgreek{~A}" string)
      (loop for char across string
        do (if (char= char #\&)
               (write-string "\\&" *tex-stream*)
               (write-char char *tex-stream*)))))

(defmethod to-tex ((bracket (eql 'bracket)) &optional (*tex-stream* *tex-stream*))
  (write-char #\] *tex-stream*))

(defmethod to-tex ((space (eql :unbreakable-space)) &optional (*tex-stream* *tex-stream*))
  (write-char #\~ *tex-stream*))

;;; It is assumed that styles are representable by text-mode LaTeX commands:
;;; \cmd{...}, which is certainly true for the set of implemented styles (Italic).
(defmethod tex-style-command (style)
  (case style
    (it "\\textit")
    (roman-numeral "\\textsc")
    (otherwise nil)))

(defvar *inside-footnote-p* nil)

;;; To TeXify the note sign, I have to insert footnote's text.  It can be
;;; conveniently accessed by means of dynamic variables.

(defvar *note-no*)
(defvar *dialogue*)

(defmethod to-tex ((note-sign (eql 'note-sign)) &optional (*tex-stream* *tex-stream*))
  (to-tex (elt (dialogue-notes *dialogue*) (incf *note-no*))))

;;; I add \hspace{0em} to enable hyphenation in the word following the note.
(defmethod to-tex ((note note) &optional (*tex-stream* *tex-stream*))
  (write-string "\\strut\\footnote{" *tex-stream*)
  (let ((*inside-footnote-p* t))
    (to-tex (note-text note)))
  (write-string "}\\hspace{0em}" *tex-stream*))

;;; Rich text
;;; Normally, rich text elements are output in a straightforward manner.
;;; However, if lettrine is used, the rules for the first cue of the first cue
;;; is different.  To deal with it, a finer system on top of parse types is
;;; needed.

(defgeneric to-tex-element (parse-object))

(defmethod to-tex-element (parse-object)
  parse-object)

(defmethod to-tex ((word rich-word) &optional (*tex-stream* *tex-stream*))
  (to-tex (rich-word-string word)))

(defmethod to-tex ((char rich-char) &optional (*tex-stream* *tex-stream*))
  (to-tex (rich-char-char char)))

(defstruct (tex-first-word (:constructor %make-tex-first-word)
                           (:constructor make-tex-first-word (rich-word &key prefix)))
  rich-word
  prefix)

(defmethod to-tex ((word tex-first-word) &optional (*tex-stream* *tex-stream*))
  (let ((string (rich-word-string (tex-first-word-rich-word word)))
        (prefix (tex-first-word-prefix word)))
    (let ((first-char (char string 0))
          (second-char "")
          (rest-chars ""))
      (when (>= (length string) 2)
        (setf second-char (char-upcase (char string 1))
              rest-chars (subseq string 2)))
      (format *tex-stream* "\\lettrine[~@[ante=~A, ~]realheight=true]{~A}{~A\\strut}~A"
              prefix
              (if (char= first-char #\Q)
                  "\\fontfamily{zgmI}\\selectfont Q"
                  first-char)
              second-char
              rest-chars))))

(defvar *first-word-p* nil)

(defmethod to-tex ((text rich-text) &optional (*tex-stream* *tex-stream*))
  (let ((last-style 'rm))
    (loop for (word . rest-words) on (rich-text-words text)
          for *first-word-p* = t then nil
          do (let ((current-style (rich-style word)))
               (when (and current-style (not (eq current-style last-style)))
                 (setf last-style current-style)
                 (let ((command (tex-style-command current-style)))
                   (when command
                     (format *tex-stream* "~A{" command)))))
          (to-tex (to-tex-element word))
          (let ((next-word (first rest-words)))
            (when (and (or (null next-word)
                           (let ((next-word-style (rich-style next-word)))
                             (and next-word-style
                                  (not (eq next-word-style last-style)))))
                       (tex-style-command last-style))
              (write-char #\} *tex-stream*))
            (when (and next-word
                       (space-between-p word next-word))
              (write-char #\Space *tex-stream*))))))

(defvar *first-cue-p* nil)
(defvar *first-word-prefix* nil)

(defmethod to-tex-element ((word rich-word))
  (if (and *first-cue-p* *first-word-p* (not *inside-footnote-p*))
      (make-tex-first-word word :prefix *first-word-prefix*)
      word))

(defstruct (tex-cue-who (:constructor %make-tex-cue-who)
                        (:constructor make-tex-cue-who (string)))
  string)

(defstruct (tex-first-cue-who (:constructor %make-first-tex-cue-who)
                              (:constructor make-first-tex-cue-who (string)))
  string)

(defun cue-who-to-tex-element (string)
  (if *first-cue-p*
      (make-first-tex-cue-who string)
      (make-tex-cue-who string)))

(defmethod to-tex ((who tex-cue-who) &optional (*tex-stream* *tex-stream*))
  (format *tex-stream* "\\textsc{~A}. " (tex-cue-who-string who)))

(defmethod to-tex ((who tex-first-cue-who) &optional (*tex-stream* *tex-stream*))
  nil)

(defmethod to-tex ((cue cue) &optional (*tex-stream* *tex-stream*))
  (let ((*first-word-prefix* (format nil "\\textsc{~A}." (cue-who cue))))
    (format *tex-stream* "~&")
    (to-tex (cue-who-to-tex-element (cue-who cue)))
    (to-tex (cue-what cue))))

(defmethod to-tex ((verse verse) &optional (*tex-stream* *tex-stream*))
  ;; Insert a blank line before verse so as to cancel lettrine's effect
  (unless *inside-footnote-p*
    (format *tex-stream* "~&~%"))
  (format *tex-stream* "~&\\begin{verse}~%\\itshape~%")
  (dolist (line (verse-lines verse))
    (to-tex line)
    (format *tex-stream* " \\\\~%"))
  (format *tex-stream* "\\end{verse}~%"))

(defmethod to-tex ((title title) &optional (*tex-stream* *tex-stream*))
  (format *tex-stream* "~&\\begin{center}~%")
  (to-tex (title-text title))
  (format *tex-stream* "~&\\end{center}~%"))

(defmethod to-tex ((personae personae) &optional (*tex-stream* *tex-stream*))
  (format *tex-stream* "~&\\begin{center}~%\\textsc{")
  (to-tex (personae-names personae))
  (format *tex-stream* "}~%\\end{center}~%"))

(defmethod to-tex ((dialogue dialogue) &optional (*tex-stream* *tex-stream*))
  (let ((*note-no* -1)
        (*dialogue* dialogue)
        (*first-cue-p* nil))
    (dolist (item (list (dialogue-title dialogue)
                        (dialogue-personae dialogue)))
      (when item
        (to-tex item)))
    (setf *first-cue-p* t)
    (dolist (chunk (dialogue-text dialogue))
      (to-tex chunk)
      (setf *first-cue-p* nil))))

(defmethod to-tex ((pathname pathname) &optional (*tex-stream* *tex-stream*))
  (to-tex (read-dialogue pathname)))


#|

Simple processing for the sake of convenience rather than flexibility.
At least this works on my machine.

|#

(defparameter *tex-geometry-for-paper*
  '((a5 :top 23 :bottom 47 :left 16 :right 33)
    (a7 :top 12 :bottom 23 :left 8 :right 16)))

(defparameter *tex-fontsize-for-paper*
  '((a5 nil)
    (a7 8)))

(defun format-simple-preamble (paper &optional (stream *tex-stream*))
  (let ((font-size (second (assoc paper *tex-fontsize-for-paper*)))
        (margins (loop for (side margin . rest-geometry) on (rest (assoc paper *tex-geometry-for-paper*)) by #'cddr
                       when margin
                       collect (list (string-downcase side) margin))))
    (format stream
"\\documentclass[~Apaper~@[, fontsize=~Apt~]]{scrbook}
\\usepackage{microtype}
%\\usepackage[osfI, swashQ]{garamondx}
%\\usepackage[greek.polutonico, latin]{babel}
%\\usepackage[utf8]{inputenc}
\\usepackage{lettrine}
\\usepackage{fontspec}
\\setmainfont{EB Garamond}
\\usepackage[~{~{~A=~Amm~}~^, ~}]{geometry}
\\hyphenation{quid-quam}
\\hyphenation{trans-la-ti-one}
\\hyphenation{trans-ver-sus}
\\hyphenation{Uten-ho-vi}
" (string-downcase paper) font-size margins)))

(defun export-colloquium-to-latex (colloquium-pathname output-directory &key preamble (paper 'a5))
  (setf colloquium-pathname (pathname colloquium-pathname))
  (let ((tex-file (merge-pathnames (make-pathname :name (pathname-name colloquium-pathname)
                                                  :type "tex")
                                   output-directory)))
    (ensure-directories-exist tex-file)
    (with-open-file (*tex-stream* tex-file
                                  :direction :output
                                  :if-exists :supersede)
      (when preamble
        (format-simple-preamble paper)
        (write-line "\\begin{document}" *tex-stream*))
      (to-tex colloquium-pathname)
      (when preamble
        (format *tex-stream* "~&\\end{document}~%")))
    tex-file))

(defun latex-to-pdf (pathname)
  (let ((output-dir (make-pathname :directory (pathname-directory pathname))))
    (uiop:run-program `("xelatex" "-output-directory" ,(uiop:native-namestring output-dir) ,(uiop:native-namestring pathname)))
    (make-pathname :defaults pathname
                   :type "pdf")))

(defmacro with-temp-dir ((directory) &body body)
  (let ((unix-name (gensym)))
    `(let ((,unix-name (uiop:run-program '("mktemp" "-d") :output '(:string :stripped t))))
       (unwind-protect
         (let ((,directory (pathname (format nil "~A/" ,unix-name))))
           ,@body)
         (uiop:run-program `("rm" "-rf" ,,unix-name))))))

(defun copy-file (from to)
  (with-open-file (in from
                      :direction :input
                      :element-type '(unsigned-byte 8))
    (with-open-file (out to
                         :direction :output
                         :element-type '(unsigned-byte 8)
                         :if-exists :supersede)
      (loop with buffer = (make-array 8192 :element-type '(unsigned-byte 8))
            for bytes-read = (read-sequence buffer in)
            while (plusp bytes-read)
            do (write-sequence buffer out :end bytes-read)))))

(defun colloquium-to-pdf (pathname &key (paper 'a5) (output-directory pathname) booklet)
  (setf pathname (pathname pathname))
  (with-temp-dir (tmp)
    (let* ((tmp-pdf (let ((pdf (latex-to-pdf (export-colloquium-to-latex pathname tmp :preamble t :paper paper))))
                      (when booklet
                        (ecase paper
                          (a5 (uiop:run-program `("pdfbook" "-o" ,(namestring tmp) ,(uiop:native-namestring pdf)))
                              (setf pdf (make-pathname :defaults pdf
                                                       :name (format nil "~A-book" (pathname-name pdf)))))
                          (a7 (uiop:run-program `("pdfbook" "-o" ,(namestring tmp) ,(uiop:native-namestring pdf)))
                              (uiop:run-program `("pdfbook" "--no-landscape" "-o" ,(namestring tmp) ,(uiop:native-namestring (make-pathname :defaults pdf
                                                                                                                                            :name (format nil "~A-book" (pathname-name pdf))))))
                              (uiop:run-program `("pdfbook" "-o" ,(namestring tmp) ,(uiop:native-namestring (make-pathname :defaults pdf
                                                                                                                           :name (format nil "~A-book-book" (pathname-name pdf))))))
                              (setf pdf (make-pathname :defaults pdf
                                                       :name (format nil "~A-book-book-book" (pathname-name pdf)))))))
                      pdf))
           (pdf (merge-pathnames (make-pathname :directory (pathname-directory output-directory)
                                                :type "pdf"
                                                :defaults pathname))))
      (copy-file tmp-pdf pdf)
      pdf)))

#|
(dolist (coll (directory "data/*.txt"))
  (print coll)
  (colloquium-to-pdf coll :output-directory "out/" :booklet t :paper 'a7))
(colloquium-to-pdf #p"data/752-alcumistica.txt" :output-directory "out/" :booklet t :paper 'a5)
(colloquium-to-pdf #p"data/838-talorum-lusus.txt" :output-directory "out/" :booklet t :paper 'a5)
(colloquium-to-pdf #p"data/838-talorum-lusus.txt" :output-directory "out/" :booklet t :paper 'a5)
(colloquium-to-pdf #p"data/838-talorum-lusus.txt" :output-directory "out/" :booklet nil :paper 'a5)
(colloquium-to-pdf #p"data/842-senatulus.txt" :output-directory "out/" :booklet t :paper 'a5)
(colloquium-to-pdf #p"data/842-senatulus.txt" :output-directory "out/" :booklet nil :paper 'a5)
(colloquium-to-pdf #p"data/749-exorcismus.txt" :output-directory "out/" :booklet t :paper 'a5)
(colloquium-to-pdf #p"data/749-exorcismus.txt" :output-directory "out/" :booklet nil :paper 'a5)
(colloquium-to-pdf #p"data/834a-ementita-nobilitas.txt" :output-directory "out/" :booklet t :paper 'a5)

(export-colloquium-to-latex #p"data/838-talorum-lusus.txt" "out/" :preamble t :paper 'a5)

(lserver:run-server :background t :home #p"lserver/")
(lserver:add-command "tex" (lambda (args) (declare (ignore args)) (colloquium-to-pdf #p"data/838-talorum-lusus.txt" :output-directory "out/" :booklet nil :paper 'a5)))
|#
